/* 
 * tclCmdMZ.c --
 *
 *      This file contains the top-level command routines for most of
 *      the Tcl built-in commands whose names begin with the letters
 *      M to Z.  It contains only commands in the generic core (i.e.
 *      those that don't depend much upon UNIX facilities).
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 * Copyright (c) 1998-2000 Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclCmdMZ.cc,v 1.2 2003/03/23 17:12:30 brucem Exp $
 */

#include "microtcl/tclInt.h"
#include "microtcl/tclPort.h"
#include "microtcl/tclCompile.h"
#include "microtcl/tclRegexp.h"

#if 0
    /*
     * Flag values used by Tcl_ScanObjCmd.
     */

    #define SCAN_NOSKIP 0x1               /* Don't skip blanks. */
    #define SCAN_SUPPRESS       0x2               /* Suppress assignment. */
    #define SCAN_UNSIGNED       0x4               /* Read an unsigned value. */
    #define SCAN_WIDTH  0x8               /* A width value was supplied. */

    #define SCAN_SIGNOK 0x10              /* A +/- character is allowed. */
    #define SCAN_NODIGITS       0x20              /* No digits have been scanned. */
    #define SCAN_NOZERO 0x40              /* No zero digits have been scanned. */
    #define SCAN_XOK    0x80              /* An 'x' is allowed. */
    #define SCAN_PTOK   0x100             /* Decimal point is allowed. */
    #define SCAN_EXPOK  0x200             /* An exponent is allowed. */
#endif

/*
 * Structure used to hold information about variable traces:
 */

typedef struct {
    int flags;                  /* Operations for which Tcl command is
                                 * to be invoked. */
    char *errMsg;               /* Error message returned from Tcl command,
                                 * or NULL.  Malloc'ed. */
    size_t length;              /* Number of non-NULL chars. in command. */
    char command[4];            /* Space for Tcl command to invoke.  Actual
                                 * size will be as large as necessary to
                                 * hold command.  This field must be the
                                 * last in the structure, so that it can
                                 * be larger than 4 bytes. */
} TraceVarInfo;

/*
 * The same structure is used for command traces at present
 */

typedef TraceVarInfo TraceCommandInfo;

/*
 * Forward declarations for procedures defined in this file:
 */

typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp,
        int optionIndex, int objc, Tcl_Obj *CONST objv[]));

// Tcl_TraceTypeObjCmd TclTraceVariableObjCmd;
// Tcl_TraceTypeObjCmd TclTraceCommandObjCmd;

/* 
 * Each subcommand has a number of 'types' to which it can apply.
 * Currently 'command' and 'variable' are the only
 * types supported.  These two arrays MUST be kept in sync!
 * In the future we may provide an API to add to the list of
 * supported trace types.
 */
/*
static char *traceTypeOptions[] = {
    "command", "variable", (char*) NULL
};
static Tcl_TraceTypeObjCmd* traceSubCmds[] = {
    TclTraceCommandObjCmd,
    TclTraceVariableObjCmd,
};
*/

static char *           TraceVarProc _ANSI_ARGS_((ClientData clientData,
                            Tcl_Interp *interp, char *name1, char *name2,
                            int flags));
static void             TraceCommandProc _ANSI_ARGS_((ClientData clientData,
                            Tcl_Interp *interp, char *oldName, char *newName,
                            int flags));


/*
 *----------------------------------------------------------------------
 *
 * Tcl_PwdObjCmd --
 *
 *      This procedure is invoked to process the "pwd" Tcl command.
 *      See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *----------------------------------------------------------------------
 */

        /* ARGSUSED */
#if 0
    int
    Tcl_PwdObjCmd(dummy, interp, objc, objv)
        ClientData dummy;                       /* Not used. */
        Tcl_Interp *interp;                     /* Current interpreter. */
        int objc;                               /* Number of arguments. */
        Tcl_Obj *CONST objv[];          /* Argument objects. */
    {
        Tcl_DString ds;

        if (objc != 1) {
            Tcl_WrongNumArgs(interp, 1, objv, NULL);
            return TCL_ERROR;
        }

        if (Tcl_GetCwd(interp, &ds) == NULL) {
            return TCL_ERROR;
        }
        Tcl_DStringResult(interp, &ds);
        return TCL_OK;
    }
#endif

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegexpObjCmd --
 *
 *      This procedure is invoked to process the "regexp" Tcl command.
 *      See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *----------------------------------------------------------------------
 */

        /* ARGSUSED */
#if 0
    int
    Tcl_RegexpObjCmd(dummy, interp, objc, objv)
        ClientData dummy;                       /* Not used. */
        Tcl_Interp *interp;                     /* Current interpreter. */
        int objc;                               /* Number of arguments. */
        Tcl_Obj *CONST objv[];          /* Argument objects. */
    {
        int i, indices, match, about, offset, all, doinline, numMatchesSaved;
        int cflags, eflags, stringLength;
        Tcl_RegExp regExpr;
        Tcl_Obj *objPtr, *resultPtr;
        Tcl_RegExpInfo info;
        static char *options[] = {
            "-all",             "-about",       "-indices",     "-inline",
            "-expanded",        "-line",        "-linestop",    "-lineanchor",
            "-nocase",  "-start",       "--",           (char *) NULL
        };
        enum options {
            REGEXP_ALL, REGEXP_ABOUT,   REGEXP_INDICES, REGEXP_INLINE,
            REGEXP_EXPANDED,REGEXP_LINE,        REGEXP_LINESTOP,REGEXP_LINEANCHOR,
            REGEXP_NOCASE,      REGEXP_START,   REGEXP_LAST
        };

        indices = 0;
        about   = 0;
        cflags  = TCL_REG_ADVANCED;
        eflags  = 0;
        offset  = 0;
        all             = 0;
        doinline        = 0;
    
        for (i = 1; i < objc; i++) {
            char *name;
            int index;

            name = Tcl_GetString(objv[i]);
            if (name[0] != '-') {
                break;
            }
            if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
                    &index) != TCL_OK) {
                return TCL_ERROR;
            }
            switch ((enum options) index) {
                case REGEXP_ALL: {
                    all = 1;
                    break;
                }
                case REGEXP_INDICES: {
                    indices = 1;
                    break;
                }
                case REGEXP_INLINE: {
                    doinline = 1;
                    break;
                }
                case REGEXP_NOCASE: {
                    cflags |= TCL_REG_NOCASE;
                    break;
                }
                case REGEXP_ABOUT: {
                    about = 1;
                    break;
                }
                case REGEXP_EXPANDED: {
                    cflags |= TCL_REG_EXPANDED;
                    break;
                }
                case REGEXP_LINE: {
                    cflags |= TCL_REG_NEWLINE;
                    break;
                }
                case REGEXP_LINESTOP: {
                    cflags |= TCL_REG_NLSTOP;
                    break;
                }
                case REGEXP_LINEANCHOR: {
                    cflags |= TCL_REG_NLANCH;
                    break;
                }
                case REGEXP_START: {
                    if (++i >= objc) {
                        goto endOfForLoop;
                    }
                    if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) {
                        return TCL_ERROR;
                    }
                    if (offset < 0) {
                        offset = 0;
                    }
                    break;
                }
                case REGEXP_LAST: {
                    i++;
                    goto endOfForLoop;
                }
            }
        }

        endOfForLoop:
        if ((objc - i) < (2 - about)) {
            Tcl_WrongNumArgs(interp, 1, objv, "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
            return TCL_ERROR;
        }
        objc -= i;
        objv += i;

        if (doinline && ((objc - 2) != 0)) {
            /*
             * User requested -inline, but specified match variables - a no-no.
             */
            Tcl_AppendResult(interp, "regexp match variables not allowed",
                    " when using -inline", (char *) NULL);
            return TCL_ERROR;
        }

        regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
        if (regExpr == NULL) {
            return TCL_ERROR;
        }
        objPtr = objv[1];

        if (about) {
            if (TclRegAbout(interp, regExpr) < 0) {
                return TCL_ERROR;
            }
            return TCL_OK;
        }

        if (offset > 0) {
            /*
             * Add flag if using offset (string is part of a larger string),
             * so that "^" won't match.
             */
            eflags |= TCL_REG_NOTBOL;
        }

        objc -= 2;
        objv += 2;
        resultPtr = Tcl_GetObjResult(interp);

        if (doinline) {
            /*
             * Save all the subexpressions, as we will return them as a list
             */
            numMatchesSaved = -1;
        } else {
            /*
             * Save only enough subexpressions for matches we want to keep,
             * expect in the case of -all, where we need to keep at least
             * one to know where to move the offset.
             */
            numMatchesSaved = (objc == 0) ? all : objc;
        }

        /*
         * Get the length of the string that we are matching against so
         * we can do the termination test for -all matches.
         */
        stringLength = Tcl_GetCharLength(objPtr);
    
        /*
         * The following loop is to handle multiple matches within the
         * same source string;  each iteration handles one match.  If "-all"
         * hasn't been specified then the loop body only gets executed once.
         * We terminate the loop when the starting offset is past the end of the
         * string.
         */

        while (1) {
            match = Tcl_RegExpExecObj(interp, regExpr, objPtr,
                    offset /* offset */, numMatchesSaved, eflags);

            if (match < 0) {
                return TCL_ERROR;
            }

            if (match == 0) {
                /*
                 * We want to set the value of the intepreter result only when
                 * this is the first time through the loop.
                 */
                if (all <= 1) {
                    /*
                     * If inlining, set the interpreter's object result to an
                     * empty list, otherwise set it to an integer object w/
                     * value 0.
                     */
                    if (doinline) {
                        Tcl_SetListObj(resultPtr, 0, NULL);
                    } else {
                        Tcl_SetIntObj(resultPtr, 0);
                    }
                    return TCL_OK;
                }
                break;
            }

            /*
             * If additional variable names have been specified, return
             * index information in those variables.
             */

            Tcl_RegExpGetInfo(regExpr, &info);
            if (doinline) {
                /*
                 * It's the number of substitutions, plus one for the matchVar
                 * at index 0
                 */
                objc = info.nsubs + 1;
            }
            for (i = 0; i < objc; i++) {
                Tcl_Obj *newPtr;

                if (indices) {
                    int start, end;
                    Tcl_Obj *objs[2];

                    if (i <= info.nsubs) {
                        start = offset + info.matches[i].start;
                        end   = offset + info.matches[i].end;

                        /*
                         * Adjust index so it refers to the last character in the
                         * match instead of the first character after the match.
                         */

                        if (end >= offset) {
                            end--;
                        }
                    } else {
                        start = -1;
                        end   = -1;
                    }

                    objs[0] = Tcl_NewLongObj(start);
                    objs[1] = Tcl_NewLongObj(end);

                    newPtr = Tcl_NewListObj(2, objs);
                } else {
                    if (i <= info.nsubs) {
                        newPtr = Tcl_GetRange(objPtr,
                                offset + info.matches[i].start,
                                offset + info.matches[i].end - 1);
                    } else {
                        newPtr = Tcl_NewObj();
                    }
                }
                if (doinline) {
                    if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr)
                            != TCL_OK) {
                        Tcl_DecrRefCount(newPtr);
                        return TCL_ERROR;
                    }
                } else {
                    Tcl_Obj *valuePtr;
                    valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0);
                    if (valuePtr == NULL) {
                        Tcl_DecrRefCount(newPtr);
                        Tcl_AppendResult(interp, "couldn't set variable \"",
                                Tcl_GetString(objv[i]), "\"", (char *) NULL);
                        return TCL_ERROR;
                    }
                }
            }

            if (all == 0) {
                break;
            }
            /*
             * Adjust the offset to the character just after the last one
             * in the matchVar and increment all to count how many times
             * we are making a match.  We always increment the offset by at least
             * one to prevent endless looping (as in the case:
             * regexp -all {a*} a).  Otherwise, when we match the NULL string at
             * the end of the input string, we will loop indefinately (because the
             * length of the match is 0, so offset never changes).
             */
            if (info.matches[0].end == 0) {
                offset++;
            }
            offset += info.matches[0].end;
            all++;
            eflags |= TCL_REG_NOTBOL;
            if (offset >= stringLength) {
                break;
            }
        }

        /*
         * Set the interpreter's object result to an integer object
         * with value 1 if -all wasn't specified, otherwise it's all-1
         * (the number of times through the while - 1).
         */

        if (!doinline) {
            Tcl_SetIntObj(resultPtr, (all ? all-1 : 1));
        }
        return TCL_OK;
    }
#endif

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegsubObjCmd --
 *
 *      This procedure is invoked to process the "regsub" Tcl command.
 *      See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *----------------------------------------------------------------------
 */

        /* ARGSUSED */
#if 0
    int
    Tcl_RegsubObjCmd(dummy, interp, objc, objv)
        ClientData dummy;                       /* Not used. */
        Tcl_Interp *interp;                     /* Current interpreter. */
        int objc;                               /* Number of arguments. */
        Tcl_Obj *CONST objv[];          /* Argument objects. */
    {
        int idx, result, cflags, all, wlen, wsublen, numMatches, offset;
        int start, end, subStart, subEnd, match;
        Tcl_RegExp regExpr;
        Tcl_RegExpInfo info;
        Tcl_Obj *resultPtr, *varPtr, *objPtr;
        Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec;

        static char *options[] = {
            "-all",             "-nocase",      "-expanded",
            "-line",    "-linestop",    "-lineanchor",  "-start",
            "--",               NULL
        };
        enum options {
            REGSUB_ALL, REGSUB_NOCASE,  REGSUB_EXPANDED,
            REGSUB_LINE,        REGSUB_LINESTOP, REGSUB_LINEANCHOR,     REGSUB_START,
            REGSUB_LAST
        };

        cflags = TCL_REG_ADVANCED;
        all = 0;
        offset = 0;

        for (idx = 1; idx < objc; idx++) {
            char *name;
            int index;
            
            name = Tcl_GetString(objv[idx]);
            if (name[0] != '-') {
                break;
            }
            if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch",
                    TCL_EXACT, &index) != TCL_OK) {
                return TCL_ERROR;
            }
            switch ((enum options) index) {
                case REGSUB_ALL: {
                    all = 1;
                    break;
                }
                case REGSUB_NOCASE: {
                    cflags |= TCL_REG_NOCASE;
                    break;
                }
                case REGSUB_EXPANDED: {
                    cflags |= TCL_REG_EXPANDED;
                    break;
                }
                case REGSUB_LINE: {
                    cflags |= TCL_REG_NEWLINE;
                    break;
                }
                case REGSUB_LINESTOP: {
                    cflags |= TCL_REG_NLSTOP;
                    break;
                }
                case REGSUB_LINEANCHOR: {
                    cflags |= TCL_REG_NLANCH;
                    break;
                }
                case REGSUB_START: {
                    if (++idx >= objc) {
                        goto endOfForLoop;
                    }
                    if (Tcl_GetIntFromObj(interp, objv[idx], &offset) != TCL_OK) {
                        return TCL_ERROR;
                    }
                    if (offset < 0) {
                        offset = 0;
                    }
                    break;
                }
                case REGSUB_LAST: {
                    idx++;
                    goto endOfForLoop;
                }
            }
        }
        endOfForLoop:
        if (objc - idx != 4) {
            Tcl_WrongNumArgs(interp, 1, objv,
                    "?switches? exp string subSpec varName");
            return TCL_ERROR;
        }

        objv += idx;

        regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
        if (regExpr == NULL) {
            return TCL_ERROR;
        }

        objPtr  = objv[1];
        wstring = Tcl_GetUnicode(objPtr);
        wlen    = Tcl_GetCharLength(objPtr);
        wsubspec        = Tcl_GetUnicode(objv[2]);
        wsublen = Tcl_GetCharLength(objv[2]);
        varPtr  = objv[3];

        result = TCL_OK;
        resultPtr = Tcl_NewUnicodeObj(wstring, 0);
        Tcl_IncrRefCount(resultPtr);

        /*
         * The following loop is to handle multiple matches within the
         * same source string;  each iteration handles one match and its
         * corresponding substitution.  If "-all" hasn't been specified
         * then the loop body only gets executed once.
         */

        numMatches = 0;
        for ( ; offset < wlen; ) {

            /*
             * The flags argument is set if string is part of a larger string,
             * so that "^" won't match.
             */

            match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset,
                    10 /* matches */, ((offset > 0) ? TCL_REG_NOTBOL : 0));

            if (match < 0) {
                result = TCL_ERROR;
                goto done;
            }
            if (match == 0) {
                break;
            }
            if ((numMatches == 0) && (offset > 0)) {
                /* Copy the initial portion of the string in if an offset
                 * was specified.
                 */
                Tcl_AppendUnicodeToObj(resultPtr, wstring, offset);
            }
            numMatches++;

            /*
             * Copy the portion of the source string before the match to the
             * result variable.
             */

            Tcl_RegExpGetInfo(regExpr, &info);
            start = info.matches[0].start;
            end = info.matches[0].end;
            Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start);

            /*
             * Append the subSpec argument to the variable, making appropriate
             * substitutions.  This code is a bit hairy because of the backslash
             * conventions and because the code saves up ranges of characters in
             * subSpec to reduce the number of calls to Tcl_SetVar.
             */

            wsrc = wfirstChar = wsubspec;
            for (ch = *wsrc; ch != '\0'; wsrc++, ch = *wsrc) {
                if (ch == '&') {
                    idx = 0;
                } else if (ch == '\\') {
                    ch = wsrc[1];
                    if ((ch >= '0') && (ch <= '9')) {
                        idx = ch - '0';
                    } else if ((ch == '\\') || (ch == '&')) {
                        *wsrc = ch;
                        Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
                                wsrc - wfirstChar + 1);
                        *wsrc = '\\';
                        wfirstChar = wsrc + 2;
                        wsrc++;
                        continue;
                    } else {
                        continue;
                    }
                } else {
                    continue;
                }
                if (wfirstChar != wsrc) {
                    Tcl_AppendUnicodeToObj(resultPtr, wfirstChar,
                            wsrc - wfirstChar);
                }
                if (idx <= info.nsubs) {
                    subStart = info.matches[idx].start;
                    subEnd = info.matches[idx].end;
                    if ((subStart >= 0) && (subEnd >= 0)) {
                        Tcl_AppendUnicodeToObj(resultPtr,
                                wstring + offset + subStart, subEnd - subStart);
                    }
                }
                if (*wsrc == '\\') {
                    wsrc++;
                }
                wfirstChar = wsrc + 1;
            }
            if (wfirstChar != wsrc) {
                Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar);
            }
            if (end == 0) {
                /*
                 * Always consume at least one character of the input string
                 * in order to prevent infinite loops.
                 */

                Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
                offset++;
            } else {
                offset += end;
            }
            if (!all) {
                break;
            }
        }

        /*
         * Copy the portion of the source string after the last match to the
         * result variable.
         */

        if (numMatches == 0) {
            /*
             * On zero matches, just ignore the offset, since it shouldn't
             * matter to us in this case, and the user may have skewed it.
             */
            Tcl_AppendUnicodeToObj(resultPtr, wstring, wlen);
        } else if (offset < wlen) {
            Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset);
        }
        if (Tcl_ObjSetVar2(interp, varPtr, NULL, resultPtr, 0) == NULL) {
            Tcl_AppendResult(interp, "couldn't set variable \"",
                    Tcl_GetString(varPtr), "\"", (char *) NULL);
            result = TCL_ERROR;
        } else {
            /*
             * Set the interpreter's object result to an integer object
             * holding the number of matches. 
             */
            
            Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches);
        }

        done:
        Tcl_DecrRefCount(resultPtr);
        return result;
    }
#endif

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RenameObjCmd --
 *
 *      This procedure is invoked to process the "rename" Tcl command.
 *      See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl object result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *----------------------------------------------------------------------
 */

        /* ARGSUSED */
int
Tcl_RenameObjCmd(dummy, interp, objc, objv)
    ClientData dummy;           /* Arbitrary value passed to the command. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    char *oldName, *newName;
    
    if (objc != 3) {
        Tcl_WrongNumArgs(interp, 1, objv, "oldName newName");
        return TCL_ERROR;
    }

    oldName = Tcl_GetString(objv[1]);
    newName = Tcl_GetString(objv[2]);
    return TclRenameCommand(interp, oldName, newName);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ReturnObjCmd --
 *
 *      This object-based procedure is invoked to process the "return" Tcl
 *      command. See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl object result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *----------------------------------------------------------------------
 */

        /* ARGSUSED */
int
Tcl_ReturnObjCmd(dummy, interp, objc, objv)
    ClientData dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    Interp *iPtr = (Interp *) interp;
    int optionLen, argLen, code, result;

    if (iPtr->errorInfo != NULL) {
        ckfree(iPtr->errorInfo);
        iPtr->errorInfo = NULL;
    }
    if (iPtr->errorCode != NULL) {
        ckfree(iPtr->errorCode);
        iPtr->errorCode = NULL;
    }
    code = TCL_OK;
    
    for (objv++, objc--;  objc > 1;  objv += 2, objc -= 2) {
        char *option = Tcl_GetStringFromObj(objv[0], &optionLen);
        char *arg = Tcl_GetStringFromObj(objv[1], &argLen);
        
        if (strcmp(option, "-code") == 0) {
            register int c = arg[0];
            if ((c == 'o') && (strcmp(arg, "ok") == 0)) {
                code = TCL_OK;
            } else if ((c == 'e') && (strcmp(arg, "error") == 0)) {
                code = TCL_ERROR;
            } else if ((c == 'r') && (strcmp(arg, "return") == 0)) {
                code = TCL_RETURN;
            } else if ((c == 'b') && (strcmp(arg, "break") == 0)) {
                code = TCL_BREAK;
            } else if ((c == 'c') && (strcmp(arg, "continue") == 0)) {
                code = TCL_CONTINUE;
            } else {
                result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1],
                        &code);
                if (result != TCL_OK) {
                    Tcl_ResetResult(interp);
                    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                            "bad completion code \"",
                            Tcl_GetString(objv[1]),
                            "\": must be ok, error, return, break, ",
                            "continue, or an integer", (char *) NULL);
                    return result;
                }
            }
        } else if (strcmp(option, "-errorinfo") == 0) {
            iPtr->errorInfo =
                (char *) ckalloc((unsigned) (strlen(arg) + 1));
            strcpy(iPtr->errorInfo, arg);
        } else if (strcmp(option, "-errorcode") == 0) {
            iPtr->errorCode =
                (char *) ckalloc((unsigned) (strlen(arg) + 1));
            strcpy(iPtr->errorCode, arg);
        } else {
            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                    "bad option \"", option,
                    "\": must be -code, -errorcode, or -errorinfo",
                    (char *) NULL);
            return TCL_ERROR;
        }
    }
    
    if (objc == 1) {
        /*
         * Set the interpreter's object result. An inline version of
         * Tcl_SetObjResult.
         */

        Tcl_SetObjResult(interp, objv[0]);
    }
    iPtr->returnCode = code;
    return TCL_RETURN;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SourceObjCmd --
 *
 *      This procedure is invoked to process the "source" Tcl command.
 *      See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl object result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *----------------------------------------------------------------------
 */

        /* ARGSUSED */
int
Tcl_SourceObjCmd(dummy, interp, objc, objv)
    ClientData dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    char *bytes;
    int result;
    
    if (objc != 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "fileName");
        return TCL_ERROR;
    }

    bytes = Tcl_GetString(objv[1]);
    result = Tcl_EvalFile(interp, bytes);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SplitObjCmd --
 *
 *      This procedure is invoked to process the "split" Tcl command.
 *      See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *----------------------------------------------------------------------
 */

        /* ARGSUSED */
int
Tcl_SplitObjCmd(dummy, interp, objc, objv)
    ClientData dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    Tcl_UniChar ch;
    int len;
    char *splitChars, *string, *end;
    int splitCharLen, stringLen;
    Tcl_Obj *listPtr, *objPtr;

    if (objc == 2) {
        splitChars = " \n\t\r";
        splitCharLen = 4;
    } else if (objc == 3) {
        splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen);
    } else {
        Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
        return TCL_ERROR;
    }

    string = Tcl_GetStringFromObj(objv[1], &stringLen);
    end = string + stringLen;
    listPtr = Tcl_GetObjResult(interp);
    
    if (stringLen == 0) {
        /*
         * Do nothing.
         */
    } else if (splitCharLen == 0) {
        /*
         * Handle the special case of splitting on every character.
         */

        for ( ; string < end; string += len) {
            len = Tcl_UtfToUniChar(string, &ch);
            objPtr = Tcl_NewStringObj(string, len);
            Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
        }
    } else {
        char *element, *p, *splitEnd;
        int splitLen;
        Tcl_UniChar splitChar;
        
        /*
         * Normal case: split on any of a given set of characters.
         * Discard instances of the split characters.
         */

        splitEnd = splitChars + splitCharLen;

        for (element = string; string < end; string += len) {
            len = Tcl_UtfToUniChar(string, &ch);
            for (p = splitChars; p < splitEnd; p += splitLen) {
                splitLen = Tcl_UtfToUniChar(p, &splitChar);
                if (ch == splitChar) {
                    objPtr = Tcl_NewStringObj(element, string - element);
                    Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
                    element = string + len;
                    break;
                }
            }
        }
        objPtr = Tcl_NewStringObj(element, string - element);
        Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_StringObjCmd --
 *
 *      This procedure is invoked to process the "string" Tcl command.
 *      See the user documentation for details on what it does.  Note
 *      that this command only functions correctly on properly formed
 *      Tcl UTF strings.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *----------------------------------------------------------------------
 */

        /* ARGSUSED */
int
Tcl_StringObjCmd(dummy, interp, objc, objv)
    ClientData dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    int index, left, right;
    Tcl_Obj *resultPtr;
    char *string1, *string2;
    int length1, length2;
    static char *options[] = {
        "bytelength",   "compare",      "equal",        "first",
        "index",        "is",           "last",         "length",
        "map",          "match",        "range",        "repeat",
        "replace",      "tolower",      "toupper",      "totitle",
        "trim",         "trimleft",     "trimright",
        "wordend",      "wordstart",    (char *) NULL
    };
    enum options {
        STR_BYTELENGTH, STR_COMPARE,    STR_EQUAL,      STR_FIRST,
        STR_INDEX,      STR_IS,         STR_LAST,       STR_LENGTH,
        STR_MAP,        STR_MATCH,      STR_RANGE,      STR_REPEAT,
        STR_REPLACE,    STR_TOLOWER,    STR_TOUPPER,    STR_TOTITLE,
        STR_TRIM,       STR_TRIMLEFT,   STR_TRIMRIGHT,
        STR_WORDEND,    STR_WORDSTART
    };    

    if (objc < 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
        return TCL_ERROR;
    }
    
    if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
            &index) != TCL_OK) {
        return TCL_ERROR;
    }

    resultPtr = Tcl_GetObjResult(interp);
    switch ((enum options) index) {
        case STR_EQUAL:
        case STR_COMPARE: {
            int i, match, length, nocase = 0, reqlength = -1;

            if (objc < 4 || objc > 7) {
            str_cmp_args:
                Tcl_WrongNumArgs(interp, 2, objv,
                                 "?-nocase? ?-length int? string1 string2");
                return TCL_ERROR;
            }

            for (i = 2; i < objc-2; i++) {
                string2 = Tcl_GetStringFromObj(objv[i], &length2);
                if ((length2 > 1)
                        && strncmp(string2, "-nocase", (size_t)length2) == 0) {
                    nocase = 1;
                } else if ((length2 > 1)
                        && strncmp(string2, "-length", (size_t)length2) == 0) {
                    if (i+1 >= objc-2) {
                        goto str_cmp_args;
                    }
                    if (Tcl_GetIntFromObj(interp, objv[++i],
                            &reqlength) != TCL_OK) {
                        return TCL_ERROR;
                    }
                } else {
                    Tcl_AppendStringsToObj(resultPtr, "bad option \"",
                            string2, "\": must be -nocase or -length",
                            (char *) NULL);
                    return TCL_ERROR;
                }
            }

            string1 = Tcl_GetStringFromObj(objv[objc-2], &length1);
            string2 = Tcl_GetStringFromObj(objv[objc-1], &length2);
            /*
             * This is the min length IN BYTES of the two strings
             */
            length = (length1 < length2) ? length1 : length2;

            if (reqlength == 0) {
                /*
                 * Anything matches at 0 chars, right?
                 */

                match = 0;
            } else if (nocase || ((reqlength > 0) && (reqlength <= length))) {
                /*
                 * with -nocase or -length we have to check true char length
                 * as it could be smaller than expected
                 */

                length1 = Tcl_NumUtfChars(string1, length1);
                length2 = Tcl_NumUtfChars(string2, length2);
                length = (length1 < length2) ? length1 : length2;

                /*
                 * Do the reqlength check again, against 0 as well for
                 * the benfit of nocase
                 */

                if ((reqlength > 0) && (reqlength < length)) {
                    length = reqlength;
                } else if (reqlength < 0) {
                    /*
                     * The requested length is negative, so we ignore it by
                     * setting it to the longer of the two lengths.
                     */

                    reqlength = (length1 > length2) ? length1 : length2;
                }
                if (nocase) {
                    match = Tcl_UtfNcasecmp(string1, string2,
                            (unsigned) length);
                } else {
                    match = Tcl_UtfNcmp(string1, string2, (unsigned) length);
                }
                if ((match == 0) && (reqlength > length)) {
                    match = length1 - length2;
                }
            } else {
                match = memcmp(string1, string2, (unsigned) length);
                if (match == 0) {
                    match = length1 - length2;
                }
            }

            if ((enum options) index == STR_EQUAL) {
                Tcl_SetBooleanObj(resultPtr, (match) ? 0 : 1);
            } else {
                Tcl_SetIntObj(resultPtr, ((match > 0) ? 1 :
                                          (match < 0) ? -1 : 0));
            }
            break;
        }
        case STR_FIRST: {
            Tcl_UniChar *ustring1, *ustring2;
            int match, start;

            if (objc < 4 || objc > 5) {
                Tcl_WrongNumArgs(interp, 2, objv,
                                 "subString string ?startIndex?");
                return TCL_ERROR;
            }

            /*
             * We are searching string2 for the sequence string1.
             */

            match = -1;
            start = 0;
            length2 = -1;

            ustring1 = Tcl_GetUnicode(objv[2]);
            length1  = Tcl_GetCharLength(objv[2]);
            ustring2 = Tcl_GetUnicode(objv[3]);
            length2  = Tcl_GetCharLength(objv[3]);

            if (objc == 5) {
                /*
                 * If a startIndex is specified, we will need to fast
                 * forward to that point in the string before we think
                 * about a match
                 */
                if (TclGetIntForIndex(interp, objv[4], length2 - 1,
                        &start) != TCL_OK) {
                    return TCL_ERROR;
                }
                if (start >= length2) {
                    goto str_first_done;
                } else if (start > 0) {
                    ustring2 += start;
                    length2  -= start;
                }
            }

            if (length1 > 0) {
                register Tcl_UniChar *p, *end;

                end = ustring2 + length2 - length1 + 1;
                for (p = ustring2;  p < end;  p++) {
                    /*
                     * Scan forward to find the first character.
                     */
                    if ((*p == *ustring1) &&
                            (Tcl_UniCharNcmp(ustring1, p,
                                    (unsigned long) length1) == 0)) {
                        match = p - ustring2;
                        break;
                    }
                }
            }
            /*
             * Compute the character index of the matching string by
             * counting the number of characters before the match.
             */
            if ((match != -1) && (objc == 5)) {
                match += start;
            }

            str_first_done:
            Tcl_SetIntObj(resultPtr, match);
            break;
        }
        case STR_INDEX: {
            if (objc != 4) {
                Tcl_WrongNumArgs(interp, 2, objv, "string charIndex");
                return TCL_ERROR;
            }

            /*
             * If we have a ByteArray object, avoid indexing in the
             * Utf string since the byte array contains one byte per
             * character.  Otherwise, use the Unicode string rep to
             * get the index'th char.
             */

            if (objv[2]->typePtr == &tclByteArrayType) {
                string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1);

                if (TclGetIntForIndex(interp, objv[3], length1 - 1,
                        &index) != TCL_OK) {
                    return TCL_ERROR;
                }
                if ((index >= 0) && (index < length1)) {
                    Tcl_SetByteArrayObj(resultPtr,
                            (unsigned char *)(&string1[index]), 1);
                }
            } else {
                /*
                 * Get Unicode char length to calulate what 'end' means.
                 */
                length1 = Tcl_GetCharLength(objv[2]);

                if (TclGetIntForIndex(interp, objv[3], length1 - 1,
                        &index) != TCL_OK) {
                    return TCL_ERROR;
                }
                if ((index >= 0) && (index < length1)) {
                    char buf[TCL_UTF_MAX];
                    Tcl_UniChar ch;

                    ch      = Tcl_GetUniChar(objv[2], index);
                    length1 = Tcl_UniCharToUtf(ch, buf);
                    Tcl_SetStringObj(resultPtr, buf, length1);
                }
            }
            break;
        }
        case STR_IS: {
            char *end;
            Tcl_UniChar ch;

            /*
             * The UniChar comparison function
             */

            int (*chcomp)_ANSI_ARGS_((int)) = NULL; 
            int i, failat = 0, result = 1, strict = 0;
            Tcl_Obj *objPtr, *failVarObj = NULL;

            static char *isOptions[] = {
                "alnum",        "alpha",        "ascii",        "control",
                "boolean",      "digit",        "double",       "false",
                "graph",        "integer",      "lower",        "print",
                "punct",        "space",        "true",         "upper",
                "wordchar",     "xdigit",       (char *) NULL
            };
            enum isOptions {
                STR_IS_ALNUM,   STR_IS_ALPHA,   STR_IS_ASCII,   STR_IS_CONTROL,
                STR_IS_BOOL,    STR_IS_DIGIT,   STR_IS_DOUBLE,  STR_IS_FALSE,
                STR_IS_GRAPH,   STR_IS_INT,     STR_IS_LOWER,   STR_IS_PRINT,
                STR_IS_PUNCT,   STR_IS_SPACE,   STR_IS_TRUE,    STR_IS_UPPER,
                STR_IS_WORD,    STR_IS_XDIGIT
            };

            if (objc < 4 || objc > 7) {
                Tcl_WrongNumArgs(interp, 2, objv,
                                 "class ?-strict? ?-failindex var? str");
                return TCL_ERROR;
            }
            if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0,
                                    &index) != TCL_OK) {
                return TCL_ERROR;
            }
            if (objc != 4) {
                for (i = 3; i < objc-1; i++) {
                    string2 = Tcl_GetStringFromObj(objv[i], &length2);
                    if ((length2 > 1) &&
                        strncmp(string2, "-strict", (size_t) length2) == 0) {
                        strict = 1;
                    } else if ((length2 > 1) &&
                            strncmp(string2, "-failindex",
                                    (size_t) length2) == 0) {
                        if (i+1 >= objc-1) {
                            Tcl_WrongNumArgs(interp, 3, objv,
                                             "?-strict? ?-failindex var? str");
                            return TCL_ERROR;
                        }
                        failVarObj = objv[++i];
                    } else {
                        Tcl_AppendStringsToObj(resultPtr, "bad option \"",
                                string2, "\": must be -strict or -failindex",
                                (char *) NULL);
                        return TCL_ERROR;
                    }
                }
            }

            /*
             * We get the objPtr so that we can short-cut for some classes
             * by checking the object type (int and double), but we need
             * the string otherwise, because we don't want any conversion
             * of type occuring (as, for example, Tcl_Get*FromObj would do
             */
            objPtr = objv[objc-1];
            string1 = Tcl_GetStringFromObj(objPtr, &length1);
            if (length1 == 0) {
                if (strict) {
                    result = 0;
                }
                goto str_is_done;
            }
            end = string1 + length1;

            /*
             * When entering here, result == 1 and failat == 0
             */
            switch ((enum isOptions) index) {
                case STR_IS_ALNUM:
                    chcomp = Tcl_UniCharIsAlnum;
                    break;
                case STR_IS_ALPHA:
                    chcomp = Tcl_UniCharIsAlpha;
                    break;
                case STR_IS_ASCII:
                    for (; string1 < end; string1++, failat++) {
                        /*
                         * This is a valid check in unicode, because all
                         * bytes < 0xC0 are single byte chars (but isascii
                         * limits that def'n to 0x80).
                         */
                        if (*((unsigned char *)string1) >= 0x80) {
                            result = 0;
                            break;
                        }
                    }
                    break;
                case STR_IS_BOOL:
                case STR_IS_TRUE:
                case STR_IS_FALSE:
                    if (objPtr->typePtr == &tclBooleanType) {
                        if ((((enum isOptions) index == STR_IS_TRUE) &&
                             objPtr->internalRep.longValue == 0) ||
                            (((enum isOptions) index == STR_IS_FALSE) &&
                             objPtr->internalRep.longValue != 0)) {
                            result = 0;
                        }
                    } else if ((Tcl_GetBoolean(NULL, string1, &i)
                                == TCL_ERROR) ||
                               (((enum isOptions) index == STR_IS_TRUE) &&
                                i == 0) ||
                               (((enum isOptions) index == STR_IS_FALSE) &&
                                i != 0)) {
                        result = 0;
                    }
                    break;
                case STR_IS_CONTROL:
                    chcomp = Tcl_UniCharIsControl;
                    break;
                case STR_IS_DIGIT:
                    chcomp = Tcl_UniCharIsDigit;
                    break;
                case STR_IS_DOUBLE: {
                    char *stop;

                    if ((objPtr->typePtr == &tclDoubleType) ||
                        (objPtr->typePtr == &tclIntType)) {
                        break;
                    }
                    /*
                     * This is adapted from Tcl_GetDouble
                     *
                     * The danger in this function is that
                     * "12345678901234567890" is an acceptable 'double',
                     * but will later be interp'd as an int by something
                     * like [expr].  Therefore, we check to see if it looks
                     * like an int, and if so we do a range check on it.
                     * If strtoul gets to the end, we know we either
                     * received an acceptable int, or over/underflow
                     */
                    if (TclLooksLikeInt(string1, length1)) {
                        errno = 0;
                        strtoul(string1, &stop, 0);
                        if (stop == end) {
                            if (errno == ERANGE) {
                                result = 0;
                                failat = -1;
                            }
                            break;
                        }
                    }
                    errno = 0;
                    strtod(string1, &stop); /* INTL: Tcl source. */
                    if (errno == ERANGE) {
                        /*
                         * if (errno == ERANGE), then it was an over/underflow
                         * problem, but in this method, we only want to know
                         * yes or no, so bad flow returns 0 (false) and sets
                         * the failVarObj to the string length.
                         */
                        result = 0;
                        failat = -1;
                    } else if (stop == string1) {
                        /*
                         * In this case, nothing like a number was found
                         */
                        result = 0;
                        failat = 0;
                    } else {
                        /*
                         * Assume we sucked up one char per byte
                         * and then we go onto SPACE, since we are
                         * allowed trailing whitespace
                         */
                        failat = stop - string1;
                        string1 = stop;
                        chcomp = Tcl_UniCharIsSpace;
                    }
                    break;
                }
                case STR_IS_GRAPH:
                    chcomp = Tcl_UniCharIsGraph;
                    break;
                case STR_IS_INT: {
                    char *stop;

                    if ((objPtr->typePtr == &tclIntType) ||
                        (Tcl_GetInt(NULL, string1, &i) == TCL_OK)) {
                        break;
                    }
                    /*
                     * Like STR_IS_DOUBLE, but we use strtoul.
                     * Since Tcl_GetInt already failed, we set result to 0.
                     */
                    result = 0;
                    errno = 0;
                    strtoul(string1, &stop, 0); /* INTL: Tcl source. */
                    if (errno == ERANGE) {
                        /*
                         * if (errno == ERANGE), then it was an over/underflow
                         * problem, but in this method, we only want to know
                         * yes or no, so bad flow returns 0 (false) and sets
                         * the failVarObj to the string length.
                         */
                        failat = -1;
                    } else if (stop == string1) {
                        /*
                         * In this case, nothing like a number was found
                         */
                        failat = 0;
                    } else {
                        /*
                         * Assume we sucked up one char per byte
                         * and then we go onto SPACE, since we are
                         * allowed trailing whitespace
                         */
                        failat = stop - string1;
                        string1 = stop;
                        chcomp = Tcl_UniCharIsSpace;
                    }
                    break;
                }
                case STR_IS_LOWER:
                    chcomp = Tcl_UniCharIsLower;
                    break;
                case STR_IS_PRINT:
                    chcomp = Tcl_UniCharIsPrint;
                    break;
                case STR_IS_PUNCT:
                    chcomp = Tcl_UniCharIsPunct;
                    break;
                case STR_IS_SPACE:
                    chcomp = Tcl_UniCharIsSpace;
                    break;
                case STR_IS_UPPER:
                    chcomp = Tcl_UniCharIsUpper;
                    break;
                case STR_IS_WORD:
                    chcomp = Tcl_UniCharIsWordChar;
                    break;
                case STR_IS_XDIGIT: {
                    for (; string1 < end; string1++, failat++) {
                        /* INTL: We assume unicode is bad for this class */
                        if ((*((unsigned char *)string1) >= 0xC0) ||
                            !isxdigit(*(unsigned char *)string1)) {
                            result = 0;
                            break;
                        }
                    }
                    break;
                }
            }
            if (chcomp != NULL) {
                for (; string1 < end; string1 += length2, failat++) {
                    length2 = Tcl_UtfToUniChar(string1, &ch);
                    if (!chcomp(ch)) {
                        result = 0;
                        break;
                    }
                }
            }
        str_is_done:
            /*
             * Only set the failVarObj when we will return 0
             * and we have indicated a valid fail index (>= 0)
             */
            if ((result == 0) && (failVarObj != NULL) &&
                Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat),
                               TCL_LEAVE_ERR_MSG) == NULL) {
                return TCL_ERROR;
            }
            Tcl_SetBooleanObj(resultPtr, result);
            break;
        }
        case STR_LAST: {
            Tcl_UniChar *ustring1, *ustring2, *p;
            int match, start;

            if (objc < 4 || objc > 5) {
                Tcl_WrongNumArgs(interp, 2, objv,
                                 "subString string ?startIndex?");
                return TCL_ERROR;
            }

            /*
             * We are searching string2 for the sequence string1.
             */

            match = -1;
            start = 0;
            length2 = -1;

            ustring1 = Tcl_GetUnicode(objv[2]);
            length1  = Tcl_GetCharLength(objv[2]);
            ustring2 = Tcl_GetUnicode(objv[3]);
            length2  = Tcl_GetCharLength(objv[3]);

            if (objc == 5) {
                /*
                 * If a startIndex is specified, we will need to restrict
                 * the string range to that char index in the string
                 */
                if (TclGetIntForIndex(interp, objv[4], length2 - 1,
                        &start) != TCL_OK) {
                    return TCL_ERROR;
                }
                if (start < 0) {
                    goto str_last_done;
                } else if (start < length2) {
                    p = ustring2 + start + 1 - length1;
                } else {
                    p = ustring2 + length2 - length1;
                }
            } else {
                p = ustring2 + length2 - length1;
            }

            if (length1 > 0) {
                for (; p >= ustring2;  p--) {
                    /*
                     * Scan backwards to find the first character.
                     */
                    if ((*p == *ustring1) &&
                            (memcmp((char *) ustring1, (char *) p, (size_t)
                                    (length1 * sizeof(Tcl_UniChar))) == 0)) {
                        match = p - ustring2;
                        break;
                    }
                }
            }

            str_last_done:
            Tcl_SetIntObj(resultPtr, match);
            break;
        }
        case STR_BYTELENGTH:
        case STR_LENGTH: {
            if (objc != 3) {
                Tcl_WrongNumArgs(interp, 2, objv, "string");
                return TCL_ERROR;
            }

            if ((enum options) index == STR_BYTELENGTH) {
                (void) Tcl_GetStringFromObj(objv[2], &length1);
            } else {
                /*
                 * If we have a ByteArray object, avoid recomputing the
                 * string since the byte array contains one byte per
                 * character.  Otherwise, use the Unicode string rep to
                 * calculate the length.
                 */

                if (objv[2]->typePtr == &tclByteArrayType) {
                    (void) Tcl_GetByteArrayFromObj(objv[2], &length1);
                } else {
                    length1 = Tcl_GetCharLength(objv[2]);
                }
            }
            Tcl_SetIntObj(resultPtr, length1);
            break;
        }
        case STR_MAP: {
            int mapElemc, nocase = 0;
            Tcl_Obj **mapElemv;
            Tcl_UniChar *ustring1, *ustring2, *p, *end;
            int (*strCmpFn)(CONST Tcl_UniChar*, CONST Tcl_UniChar*,
                    unsigned long);

            if (objc < 4 || objc > 5) {
                Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string");
                return TCL_ERROR;
            }

            if (objc == 5) {
                string2 = Tcl_GetStringFromObj(objv[2], &length2);
                if ((length2 > 1) &&
                    strncmp(string2, "-nocase", (size_t) length2) == 0) {
                    nocase = 1;
                } else {
                    Tcl_AppendStringsToObj(resultPtr, "bad option \"",
                                           string2, "\": must be -nocase",
                                           (char *) NULL);
                    return TCL_ERROR;
                }
            }

            if (Tcl_ListObjGetElements(interp, objv[objc-2], &mapElemc,
                                       &mapElemv) != TCL_OK) {
                return TCL_ERROR;
            }
            if (mapElemc == 0) {
                /*
                 * empty charMap, just return whatever string was given
                 */
                Tcl_SetObjResult(interp, objv[objc-1]);
            } else if (mapElemc & 1) {
                /*
                 * The charMap must be an even number of key/value items
                 */
                Tcl_SetStringObj(resultPtr, "char map list unbalanced", -1);
                return TCL_ERROR;
            }
            objc--;

            ustring1 = Tcl_GetUnicode(objv[objc]);
            length1  = Tcl_GetCharLength(objv[objc]);
            if (length1 == 0) {
                /*
                 * Empty input string, just stop now
                 */
                break;
            }
            end = ustring1 + length1;

            strCmpFn = (nocase) ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;

            /*
             * Force result to be Unicode
             */
            Tcl_SetUnicodeObj(resultPtr, ustring1, 0);

            if (mapElemc == 2) {
                /*
                 * Special case for one map pair which avoids the extra
                 * for loop and extra calls to get Unicode data.  The
                 * algorithm is otherwise identical to the multi-pair case.
                 * This will be >30% faster on larger strings.
                 */
                Tcl_UniChar *mapString = Tcl_GetUnicode(mapElemv[1]);
                int mapLen = Tcl_GetCharLength(mapElemv[1]);
                ustring2 = Tcl_GetUnicode(mapElemv[0]);
                length2  = Tcl_GetCharLength(mapElemv[0]);
                for (p = ustring1; ustring1 < end; ustring1++) {
                    if ((length2 > 0) &&
                            (nocase || (*ustring1 == *ustring2)) &&
                            (strCmpFn(ustring1, ustring2,
                                    (unsigned long) length2) == 0)) {
                        if (p != ustring1) {
                            Tcl_AppendUnicodeToObj(resultPtr, p,
                                    ustring1 - p);
                            p = ustring1 + length2;
                        } else {
                            p += length2;
                        }
                        ustring1 = p - 1;

                        Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen);
                    }
                }
            } else {
                Tcl_UniChar **mapStrings =
                    (Tcl_UniChar **) ckalloc((mapElemc * 2)
                            * sizeof(Tcl_UniChar *));
                int *mapLens =
                    (int *) ckalloc((mapElemc * 2) * sizeof(int));
                /*
                 * Precompute pointers to the unicode string and length.
                 * This saves us repeated function calls later,
                 * significantly speeding up the algorithm.
                 */
                for (index = 0; index < mapElemc; index++) {
                    mapStrings[index] = Tcl_GetUnicode(mapElemv[index]);
                    mapLens[index]    = Tcl_GetCharLength(mapElemv[index]);
                }
                for (p = ustring1; ustring1 < end; ustring1++) {
                    for (index = 0; index < mapElemc; index += 2) {
                        /*
                         * Get the key string to match on
                         */
                        ustring2 = mapStrings[index];
                        length2  = mapLens[index];
                        if ((length2 > 0) &&
                                (nocase || (*ustring1 == *ustring2)) &&
                                (strCmpFn(ustring2, ustring1,
                                        (unsigned long) length2) == 0)) {
                            if (p != ustring1) {
                                /*
                                 * Put the skipped chars onto the result first
                                 */
                                Tcl_AppendUnicodeToObj(resultPtr, p,
                                        ustring1 - p);
                                p = ustring1 + length2;
                            } else {
                                p += length2;
                            }
                            /*
                             * Adjust len to be full length of matched string
                             */
                            ustring1 = p - 1;

                            /*
                             * Append the map value to the unicode string
                             */
                            Tcl_AppendUnicodeToObj(resultPtr,
                                    mapStrings[index+1], mapLens[index+1]);
                            break;
                        }
                    }
                }
                ckfree((char *) mapStrings);
                ckfree((char *) mapLens);
            }
            if (p != ustring1) {
                /*
                 * Put the rest of the unmapped chars onto result
                 */
                Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p);
            }
            break;
        }
        case STR_MATCH: {
            int nocase = 0;

            if (objc < 4 || objc > 5) {
                Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string");
                return TCL_ERROR;
            }

            if (objc == 5) {
                string2 = Tcl_GetStringFromObj(objv[2], &length2);
                if ((length2 > 1) &&
                    strncmp(string2, "-nocase", (size_t) length2) == 0) {
                    nocase = 1;
                } else {
                    Tcl_AppendStringsToObj(resultPtr, "bad option \"",
                                           string2, "\": must be -nocase",
                                           (char *) NULL);
                    return TCL_ERROR;
                }
            }

            Tcl_SetBooleanObj(resultPtr,
                    Tcl_UniCharCaseMatch(Tcl_GetUnicode(objv[objc-1]),
                            Tcl_GetUnicode(objv[objc-2]), nocase));
            break;
        }
        case STR_RANGE: {
            int first, last;

            if (objc != 5) {
                Tcl_WrongNumArgs(interp, 2, objv, "string first last");
                return TCL_ERROR;
            }

            /*
             * Get the length in actual characters.
             */
            length1 = Tcl_GetCharLength(objv[2]) - 1;

            if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK)
                    || (TclGetIntForIndex(interp, objv[4], length1,
                            &last) != TCL_OK)) {
                return TCL_ERROR;
            }

            if (first < 0) {
                first = 0;
            }
            if (last >= length1) {
                last = length1;
            }
            if (last >= first) {
                Tcl_SetObjResult(interp, Tcl_GetRange(objv[2], first, last));
            }
            break;
        }
        case STR_REPEAT: {
            int count;

            if (objc != 4) {
                Tcl_WrongNumArgs(interp, 2, objv, "string count");
                return TCL_ERROR;
            }

            if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) {
                return TCL_ERROR;
            }

            if (count == 1) {
                Tcl_SetObjResult(interp, objv[2]);
            } else if (count > 1) {
                string1 = Tcl_GetStringFromObj(objv[2], &length1);
                if (length1 > 0) {
                    /*
                     * Only build up a string that has data.  Instead of
                     * building it up with repeated appends, we just allocate
                     * the necessary space once and copy the string value in.
                     */
                    length2             = length1 * count;
                    /*
                     * Include space for the NULL
                     */
                    string2             = (char *) ckalloc((size_t) length2+1);
                    for (index = 0; index < count; index++) {
                        memcpy(string2 + (length1 * index), string1,
                                (size_t) length1);
                    }
                    string2[length2]    = '\0';
                    /*
                     * We have to directly assign this instead of using
                     * Tcl_SetStringObj (and indirectly TclInitStringRep)
                     * because that makes another copy of the data.
                     */
                    resultPtr           = Tcl_NewObj();
                    resultPtr->bytes    = string2;
                    resultPtr->length   = length2;
                    Tcl_SetObjResult(interp, resultPtr);
                }
            }
            break;
        }
        case STR_REPLACE: {
            Tcl_UniChar *ustring1;
            int first, last;

            if (objc < 5 || objc > 6) {
                Tcl_WrongNumArgs(interp, 2, objv,
                                 "string first last ?string?");
                return TCL_ERROR;
            }

            ustring1 = Tcl_GetUnicode(objv[2]);
            length1  = Tcl_GetCharLength(objv[2]) - 1;

            if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK)
                    || (TclGetIntForIndex(interp, objv[4], length1,
                            &last) != TCL_OK)) {
                return TCL_ERROR;
            }

            if ((last < first) || (last < 0) || (first > length1)) {
                Tcl_SetObjResult(interp, objv[2]);
            } else {
                if (first < 0) {
                    first = 0;
                }

                Tcl_SetUnicodeObj(resultPtr, ustring1, first);
                if (objc == 6) {
                    Tcl_AppendObjToObj(resultPtr, objv[5]);
                }
                if (last < length1) {
                    Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1,
                            length1 - last);
                }
            }
            break;
        }
        case STR_TOLOWER:
        case STR_TOUPPER:
        case STR_TOTITLE:
            if (objc < 3 || objc > 5) {
                Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?");
                return TCL_ERROR;
            }

            string1 = Tcl_GetStringFromObj(objv[2], &length1);

            if (objc == 3) {
                /*
                 * Since the result object is not a shared object, it is
                 * safe to copy the string into the result and do the
                 * conversion in place.  The conversion may change the length
                 * of the string, so reset the length after conversion.
                 */

                Tcl_SetStringObj(resultPtr, string1, length1);
                if ((enum options) index == STR_TOLOWER) {
                    length1 = Tcl_UtfToLower(Tcl_GetString(resultPtr));
                } else if ((enum options) index == STR_TOUPPER) {
                    length1 = Tcl_UtfToUpper(Tcl_GetString(resultPtr));
                } else {
                    length1 = Tcl_UtfToTitle(Tcl_GetString(resultPtr));
                }
                Tcl_SetObjLength(resultPtr, length1);
            } else {
                int first, last;
                char *start, *end;

                length1 = Tcl_NumUtfChars(string1, length1) - 1;
                if (TclGetIntForIndex(interp, objv[3], length1,
                                      &first) != TCL_OK) {
                    return TCL_ERROR;
                }
                if (first < 0) {
                    first = 0;
                }
                last = first;
                if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1,
                                                      &last) != TCL_OK)) {
                    return TCL_ERROR;
                }
                if (last >= length1) {
                    last = length1;
                }
                if (last < first) {
                    Tcl_SetObjResult(interp, objv[2]);
                    break;
                }
                start = Tcl_UtfAtIndex(string1, first);
                end = Tcl_UtfAtIndex(start, last - first + 1);
                length2 = end-start;
                string2 = ckalloc((size_t) length2+1);
                memcpy(string2, start, (size_t) length2);
                string2[length2] = '\0';
                if ((enum options) index == STR_TOLOWER) {
                    length2 = Tcl_UtfToLower(string2);
                } else if ((enum options) index == STR_TOUPPER) {
                    length2 = Tcl_UtfToUpper(string2);
                } else {
                    length2 = Tcl_UtfToTitle(string2);
                }
                Tcl_SetStringObj(resultPtr, string1, start - string1);
                Tcl_AppendToObj(resultPtr, string2, length2);
                Tcl_AppendToObj(resultPtr, end, -1);
                ckfree(string2);
            }
            break;

        case STR_TRIM: {
            Tcl_UniChar ch, trim;
            register char *p, *end;
            char *check, *checkEnd;
            int offset;

            left = 1;
            right = 1;

            dotrim:
            if (objc == 4) {
                string2 = Tcl_GetStringFromObj(objv[3], &length2);
            } else if (objc == 3) {
                string2 = " \t\n\r";
                length2 = strlen(string2);
            } else {
                Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?");
                return TCL_ERROR;
            }
            string1 = Tcl_GetStringFromObj(objv[2], &length1);
            checkEnd = string2 + length2;

            if (left) {
                end = string1 + length1;
                /*
                 * The outer loop iterates over the string.  The inner
                 * loop iterates over the trim characters.  The loops
                 * terminate as soon as a non-trim character is discovered
                 * and string1 is left pointing at the first non-trim
                 * character.
                 */

                for (p = string1; p < end; p += offset) {
                    offset = Tcl_UtfToUniChar(p, &ch);
                    
                    for (check = string2; ; ) {
                        if (check >= checkEnd) {
                            p = end;
                            break;
                        }
                        check += Tcl_UtfToUniChar(check, &trim);
                        if (ch == trim) {
                            length1 -= offset;
                            string1 += offset;
                            break;
                        }
                    }
                }
            }
            if (right) {
                end = string1;

                /*
                 * The outer loop iterates over the string.  The inner
                 * loop iterates over the trim characters.  The loops
                 * terminate as soon as a non-trim character is discovered
                 * and length1 marks the last non-trim character.
                 */

                for (p = string1 + length1; p > end; ) {
                    p = Tcl_UtfPrev(p, string1);
                    offset = Tcl_UtfToUniChar(p, &ch);
                    for (check = string2; ; ) {
                        if (check >= checkEnd) {
                            p = end;
                            break;
                        }
                        check += Tcl_UtfToUniChar(check, &trim);
                        if (ch == trim) {
                            length1 -= offset;
                            break;
                        }
                    }
                }
            }
            Tcl_SetStringObj(resultPtr, string1, length1);
            break;
        }
        case STR_TRIMLEFT: {
            left = 1;
            right = 0;
            goto dotrim;
        }
        case STR_TRIMRIGHT: {
            left = 0;
            right = 1;
            goto dotrim;
        }
        case STR_WORDEND: {
            int cur;
            Tcl_UniChar ch;
            char *p, *end;
            int numChars;
            
            if (objc != 4) {
                Tcl_WrongNumArgs(interp, 2, objv, "string index");
                return TCL_ERROR;
            }

            string1 = Tcl_GetStringFromObj(objv[2], &length1);
            numChars = Tcl_NumUtfChars(string1, length1);
            if (TclGetIntForIndex(interp, objv[3], numChars-1,
                                  &index) != TCL_OK) {
                return TCL_ERROR;
            }
            if (index < 0) {
                index = 0;
            }
            if (index < numChars) {
                p = Tcl_UtfAtIndex(string1, index);
                end = string1+length1;
                for (cur = index; p < end; cur++) {
                    p += Tcl_UtfToUniChar(p, &ch);
                    if (!Tcl_UniCharIsWordChar(ch)) {
                        break;
                    }
                }
                if (cur == index) {
                    cur++;
                }
            } else {
                cur = numChars;
            }
            Tcl_SetIntObj(resultPtr, cur);
            break;
        }
        case STR_WORDSTART: {
            int cur;
            Tcl_UniChar ch;
            char *p;
            int numChars;
            
            if (objc != 4) {
                Tcl_WrongNumArgs(interp, 2, objv, "string index");
                return TCL_ERROR;
            }

            string1 = Tcl_GetStringFromObj(objv[2], &length1);
            numChars = Tcl_NumUtfChars(string1, length1);
            if (TclGetIntForIndex(interp, objv[3], numChars-1,
                                  &index) != TCL_OK) {
                return TCL_ERROR;
            }
            if (index >= numChars) {
                index = numChars - 1;
            }
            cur = 0;
            if (index > 0) {
                p = Tcl_UtfAtIndex(string1, index);
                for (cur = index; cur >= 0; cur--) {
                    Tcl_UtfToUniChar(p, &ch);
                    if (!Tcl_UniCharIsWordChar(ch)) {
                        break;
                    }
                    p = Tcl_UtfPrev(p, string1);
                }
                if (cur != index) {
                    cur += 1;
                }
            }
            Tcl_SetIntObj(resultPtr, cur);
            break;
        }
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SubstObjCmd --
 *
 *      This procedure is invoked to process the "subst" Tcl command.
 *      See the user documentation for details on what it does.  This
 *      command is an almost direct copy of an implementation by
 *      Andrew Payne.
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *----------------------------------------------------------------------
 */

        /* ARGSUSED */
int
Tcl_SubstObjCmd(dummy, interp, objc, objv)
    ClientData dummy;                   /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    int objc;                           /* Number of arguments. */
    Tcl_Obj *CONST objv[];              /* Argument objects. */
{
    static char *substOptions[] = {
        "-nobackslashes", "-nocommands", "-novariables", (char *) NULL
    };
    enum substOptions {
        SUBST_NOBACKSLASHES,      SUBST_NOCOMMANDS,       SUBST_NOVARS
    };
    Interp *iPtr = (Interp *) interp;
    Tcl_DString result;
    char *p, *old, *value;
    int optionIndex, code, count, doVars, doCmds, doBackslashes, i;

    /*
     * Parse command-line options.
     */

    doVars = doCmds = doBackslashes = 1;
    for (i = 1; i < (objc-1); i++) {
        p = Tcl_GetString(objv[i]);
        if (*p != '-') {
            break;
        }
        if (Tcl_GetIndexFromObj(interp, objv[i], substOptions,
                "switch", 0, &optionIndex) != TCL_OK) {

            return TCL_ERROR;
        }
        switch (optionIndex) {
            case SUBST_NOBACKSLASHES: {
                doBackslashes = 0;
                break;
            }
            case SUBST_NOCOMMANDS: {
                doCmds = 0;
                break;
            }
            case SUBST_NOVARS: {
                doVars = 0;
                break;
            }
            default: {
                panic("Tcl_SubstObjCmd: bad option index to SubstOptions");
            }
        }
    }
    if (i != (objc-1)) {
        Tcl_WrongNumArgs(interp, 1, objv,
                "?-nobackslashes? ?-nocommands? ?-novariables? string");
        return TCL_ERROR;
    }

    /*
     * Scan through the string one character at a time, performing
     * command, variable, and backslash substitutions.
     */

    Tcl_DStringInit(&result);
    old = p = Tcl_GetString(objv[i]);
    while (*p != 0) {
        switch (*p) {
            case '\\':
                if (doBackslashes) {
                    char buf[TCL_UTF_MAX];

                    if (p != old) {
                        Tcl_DStringAppend(&result, old, p-old);
                    }
                    Tcl_DStringAppend(&result, buf,
                            Tcl_UtfBackslash(p, &count, buf));
                    p += count;
                    old = p;
                } else {
                    p++;
                }
                break;

            case '$':
                if (doVars) {
                    if (p != old) {
                        Tcl_DStringAppend(&result, old, p-old);
                    }
                    value = Tcl_ParseVar(interp, p, &p);
                    if (value == NULL) {
                        Tcl_DStringFree(&result);
                        return TCL_ERROR;
                    }
                    Tcl_DStringAppend(&result, value, -1);
                    old = p;
                } else {
                    p++;
                }
                break;

            case '[':
                if (doCmds) {
                    if (p != old) {
                        Tcl_DStringAppend(&result, old, p-old);
                    }
                    iPtr->evalFlags = TCL_BRACKET_TERM;
                    code = Tcl_Eval(interp, p+1);
                    if (code == TCL_ERROR) {
                        Tcl_DStringFree(&result);
                        return code;
                    }
                    old = p = (p+1 + iPtr->termOffset+1);
                    Tcl_DStringAppend(&result, iPtr->result, -1);
                    Tcl_ResetResult(interp);
                } else {
                    p++;
                }
                break;

            default:
                p++;
                break;
        }
    }
    if (p != old) {
        Tcl_DStringAppend(&result, old, p-old);
    }
    Tcl_DStringResult(interp, &result);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SwitchObjCmd --
 *
 *      This object-based procedure is invoked to process the "switch" Tcl
 *      command. See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl object result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *----------------------------------------------------------------------
 */

        /* ARGSUSED */
int
Tcl_SwitchObjCmd(dummy, interp, objc, objv)
    ClientData dummy;           /* Not used. */
    Tcl_Interp *interp;         /* Current interpreter. */
    int objc;                   /* Number of arguments. */
    Tcl_Obj *CONST objv[];      /* Argument objects. */
{
    int i, j, index, mode, matched, result, splitObjs, seenComment;
    char *string, *pattern;
    Tcl_Obj *stringObj;
    static char *options[] = {
        "-exact",       "-glob",        "-regexp",      "--", 
        NULL
    };
    enum options {
        OPT_EXACT,      OPT_GLOB,       OPT_REGEXP,     OPT_LAST
    };

    mode = OPT_EXACT;
    for (i = 1; i < objc; i++) {
        string = Tcl_GetString(objv[i]);
        if (string[0] != '-') {
            break;
        }
        if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, 
                &index) != TCL_OK) {
            return TCL_ERROR;
        }
        if (index == OPT_LAST) {
            i++;
            break;
        }
        mode = index;
    }

    if (objc - i < 2) {
        Tcl_WrongNumArgs(interp, 1, objv,
                "?switches? string pattern body ... ?default body?");
        return TCL_ERROR;
    }

    stringObj = objv[i];
    objc -= i + 1;
    objv += i + 1;

    /*
     * If all of the pattern/command pairs are lumped into a single
     * argument, split them out again.
     */

    splitObjs = 0;
    if (objc == 1) {
        Tcl_Obj **listv;

        if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) {
            return TCL_ERROR;
        }
        objv = listv;
        splitObjs = 1;
    }

    seenComment = 0;
    for (i = 0; i < objc; i += 2) {
        if (i == objc - 1) {
            Tcl_ResetResult(interp);
            Tcl_AppendToObj(Tcl_GetObjResult(interp),
                    "extra switch pattern with no body", -1);

            /*
             * Check if this can be due to a badly placed comment
             * in the switch block
             */

            if (splitObjs && seenComment) {
                Tcl_AppendToObj(Tcl_GetObjResult(interp),
                        ", this may be due to a comment incorrectly placed outside of a switch body - see the \"switch\" documentation", -1);
            }

            return TCL_ERROR;
        }

        /*
         * See if the pattern matches the string.
         */

        pattern = Tcl_GetString(objv[i]);

        /*
         * The following is an heuristic to detect the infamous
         * "comment in switch" error: just check if a pattern
         * begins with '#'.
         */

        if (splitObjs && *pattern == '#') {
            seenComment = 1;
        }

        matched = 0;
        if ((i == objc - 2) 
                && (*pattern == 'd') 
                && (strcmp(pattern, "default") == 0)) {
            matched = 1;
        } else {
            switch (mode) {
                case OPT_EXACT:
                    matched = (strcmp(Tcl_GetString(stringObj), pattern) == 0);
                    break;
                case OPT_GLOB:
                    matched = Tcl_StringMatch(Tcl_GetString(stringObj),
                            pattern);
                    break;
                case OPT_REGEXP:
                    matched = 0;
// FIXME FLOH
//                    matched = Tcl_RegExpMatchObj(interp, stringObj, objv[i]);
//                    if (matched < 0) {
//                        return TCL_ERROR;
//                   }
                    break;
            }
        }
        if (matched == 0) {
            continue;
        }

        /*
         * We've got a match. Find a body to execute, skipping bodies
         * that are "-".
         */

        for (j = i + 1; ; j += 2) {
            if (j >= objc) {
                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                        "no body specified for pattern \"", pattern,
                        "\"", (char *) NULL);
                return TCL_ERROR;
            }
            if (strcmp(Tcl_GetString(objv[j]), "-") != 0) {
                break;
            }
        }
        result = Tcl_EvalObjEx(interp, objv[j], 0);
        if (result == TCL_ERROR) {
            char msg[100 + TCL_INTEGER_SPACE];

            sprintf(msg, "\n    (\"%.50s\" arm line %d)", pattern,
                    interp->errorLine);
            Tcl_AddObjErrorInfo(interp, msg, -1);
        }
        return result;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TimeObjCmd --
 *
 *      This object-based procedure is invoked to process the "time" Tcl
 *      command.  See the user documentation for details on what it does.
 *
 * Results:
 *      A standard Tcl object result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *----------------------------------------------------------------------
 */

        /* ARGSUSED */
#if 0
    int
    Tcl_TimeObjCmd(dummy, interp, objc, objv)
        ClientData dummy;               /* Not used. */
        Tcl_Interp *interp;             /* Current interpreter. */
        int objc;                       /* Number of arguments. */
        Tcl_Obj *CONST objv[];  /* Argument objects. */
    {
        register Tcl_Obj *objPtr;
        register int i, result;
        int count;
        double totalMicroSec;
        Tcl_Time start, stop;
        char buf[100];

        if (objc == 2) {
            count = 1;
        } else if (objc == 3) {
            result = Tcl_GetIntFromObj(interp, objv[2], &count);
            if (result != TCL_OK) {
                return result;
            }
        } else {
            Tcl_WrongNumArgs(interp, 1, objv, "command ?count?");
            return TCL_ERROR;
        }
    
        objPtr = objv[1];
        i = count;
        TclpGetTime(&start);
        while (i-- > 0) {
            result = Tcl_EvalObjEx(interp, objPtr, 0);
            if (result != TCL_OK) {
                return result;
            }
        }
        TclpGetTime(&stop);
    
        totalMicroSec =
            (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
        sprintf(buf, "%.0f microseconds per iteration",
            ((count <= 0) ? 0 : totalMicroSec/count));
        Tcl_ResetResult(interp);
        Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
        return TCL_OK;
    }
#endif

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TraceObjCmd --
 *
 *      This procedure is invoked to process the "trace" Tcl command.
 *      See the user documentation for details on what it does.
 *      
 *      Standard syntax as of Tcl 8.4 is
 *      
 *       trace {add|remove|list} {command|variable} name ops cmd
 *
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *----------------------------------------------------------------------
 */

        /* ARGSUSED */
#if 0

    int
    Tcl_TraceObjCmd(dummy, interp, objc, objv)
        ClientData dummy;                       /* Not used. */
        Tcl_Interp *interp;                     /* Current interpreter. */
        int objc;                               /* Number of arguments. */
        Tcl_Obj *CONST objv[];          /* Argument objects. */
    {
        int optionIndex, commandLength;
        char *name, *flagOps, *command, *p;
        size_t length;
        /* Main sub commands to 'trace' */
        static char *traceOptions[] = {
            "add", "list", "remove", 
    #ifndef TCL_REMOVE_OBSOLETE_TRACES
            "variable", "vdelete", "vinfo", 
    #endif
            (char *) NULL
        };
        /* 'OLD' options are pre-Tcl-8.4 style */
        enum traceOptions {
            TRACE_ADD, TRACE_LIST, TRACE_REMOVE, 
    #ifndef TCL_REMOVE_OBSOLETE_TRACES
            TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO
    #endif
        };

        if (objc < 2) {
            Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
            return TCL_ERROR;
        }

        if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions,
                    "option", 0, &optionIndex) != TCL_OK) {
            return TCL_ERROR;
        }
        switch ((enum traceOptions) optionIndex) {
            case TRACE_ADD: 
            case TRACE_REMOVE:
            case TRACE_LIST: {
                /* 
                 * All sub commands of trace add/remove must take at least
                 * one more argument.  Beyond that we let the subcommand itself
                 * control the argument structure.
                 */
                int typeIndex;
                if (objc < 3) {
                    Tcl_WrongNumArgs(interp, 2, objv, "type ?arg arg ...?");
                    return TCL_ERROR;
                }
                if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions,
                            "option", 0, &typeIndex) != TCL_OK) {
                    return TCL_ERROR;
                }
                return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv);
                break;
            }
    #ifndef TCL_REMOVE_OBSOLETE_TRACES
            case TRACE_OLD_VARIABLE: {
                int flags;
                TraceVarInfo *tvarPtr;
                if (objc != 5) {
                    Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
                    return TCL_ERROR;
                }

                flags = 0;
                flagOps = Tcl_GetString(objv[3]);
                for (p = flagOps; *p != 0; p++) {
                    if (*p == 'r') {
                        flags |= TCL_TRACE_READS;
                    } else if (*p == 'w') {
                        flags |= TCL_TRACE_WRITES;
                    } else if (*p == 'u') {
                        flags |= TCL_TRACE_UNSETS;
                    } else if (*p == 'a') {
                        flags |= TCL_TRACE_ARRAY;
                    } else {
                        goto badVarOps;
                    }
                }
                if (flags == 0) {
                    goto badVarOps;
                }
                flags |= TCL_TRACE_OLD_STYLE;
                
                command = Tcl_GetStringFromObj(objv[4], &commandLength);
                length = (size_t) commandLength;
                tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
                        (sizeof(TraceVarInfo) - sizeof(tvarPtr->command)
                                + length + 1));
                tvarPtr->flags = flags;
                tvarPtr->errMsg = NULL;
                tvarPtr->length = length;
                flags |= TCL_TRACE_UNSETS;
                strcpy(tvarPtr->command, command);
                name = Tcl_GetString(objv[2]);
                if (Tcl_TraceVar(interp, name, flags, TraceVarProc,
                        (ClientData) tvarPtr) != TCL_OK) {
                    ckfree((char *) tvarPtr);
                    return TCL_ERROR;
                }
                break;
            }
            case TRACE_OLD_VDELETE: {
                int flags;
                TraceVarInfo *tvarPtr;
                ClientData clientData;

                if (objc != 5) {
                    Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
                    return TCL_ERROR;
                }

                flags = 0;
                flagOps = Tcl_GetString(objv[3]);
                for (p = flagOps; *p != 0; p++) {
                    if (*p == 'r') {
                        flags |= TCL_TRACE_READS;
                    } else if (*p == 'w') {
                        flags |= TCL_TRACE_WRITES;
                    } else if (*p == 'u') {
                        flags |= TCL_TRACE_UNSETS;
                    } else if (*p == 'a') {
                        flags |= TCL_TRACE_ARRAY;
                    } else {
                        goto badVarOps;
                    }
                }
                if (flags == 0) {
                    goto badVarOps;
                }
                flags |= TCL_TRACE_OLD_STYLE;

                /*
                 * Search through all of our traces on this variable to
                 * see if there's one with the given command.  If so, then
                 * delete the first one that matches.
                 */

                command = Tcl_GetStringFromObj(objv[4], &commandLength);
                length = (size_t) commandLength;
                clientData = 0;
                name = Tcl_GetString(objv[2]);
                while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
                        TraceVarProc, clientData)) != 0) {
                    tvarPtr = (TraceVarInfo *) clientData;
                    if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
                            && (strncmp(command, tvarPtr->command,
                                    (size_t) length) == 0)) {
                        Tcl_UntraceVar(interp, name, flags | TCL_TRACE_UNSETS,
                                TraceVarProc, clientData);
                        if (tvarPtr->errMsg != NULL) {
                            ckfree(tvarPtr->errMsg);
                        }
                        ckfree((char *) tvarPtr);
                        break;
                    }
                }
                break;
            }
            case TRACE_OLD_VINFO: {
                ClientData clientData;
                char ops[5];
                Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;

                if (objc != 3) {
                    Tcl_WrongNumArgs(interp, 2, objv, "name");
                    return TCL_ERROR;
                }
                resultListPtr = Tcl_GetObjResult(interp);
                clientData = 0;
                name = Tcl_GetString(objv[2]);
                while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
                        TraceVarProc, clientData)) != 0) {

                    TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;

                    pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
                    p = ops;
                    if (tvarPtr->flags & TCL_TRACE_READS) {
                        *p = 'r';
                        p++;
                    }
                    if (tvarPtr->flags & TCL_TRACE_WRITES) {
                        *p = 'w';
                        p++;
                    }
                    if (tvarPtr->flags & TCL_TRACE_UNSETS) {
                        *p = 'u';
                        p++;
                    }
                    if (tvarPtr->flags & TCL_TRACE_ARRAY) {
                        *p = 'a';
                        p++;
                    }
                    *p = '\0';

                    /*
                     * Build a pair (2-item list) with the ops string as
                     * the first obj element and the tvarPtr->command string
                     * as the second obj element.  Append the pair (as an
                     * element) to the end of the result object list.
                     */

                    elemObjPtr = Tcl_NewStringObj(ops, -1);
                    Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
                    elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
                    Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
                    Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr);
                }
                Tcl_SetObjResult(interp, resultListPtr);
                break;
            }
    #endif /* TCL_REMOVE_OBSOLETE_TRACES */
        }
        return TCL_OK;

        badVarOps:
        Tcl_AppendResult(interp, "bad operations \"", flagOps,
                "\": should be one or more of rwua", (char *) NULL);
        return TCL_ERROR;
    }
#endif


/*
 *----------------------------------------------------------------------
 *
 * TclTraceCommandObjCmd --
 *
 *      Helper function for Tcl_TraceObjCmd; implements the
 *      [trace {add|remove|list} command ...] subcommands.
 *      See the user documentation for details on what these do.
 *
 * Results:
 *      Standard Tcl result.
 *
 * Side effects:
 *      Depends on the operation (add, remove, or list) being performed;
 *      may add or remove command traces on a command.
 *
 *----------------------------------------------------------------------
 */

#if 0
    int
    TclTraceCommandObjCmd(interp, optionIndex, objc, objv)
        Tcl_Interp *interp;                     /* Current interpreter. */
        int optionIndex;                        /* Add, list or remove */
        int objc;                               /* Number of arguments. */
        Tcl_Obj *CONST objv[];          /* Argument objects. */
    {
        int commandLength, index;
        char *name, *command;
        size_t length;
        enum traceOptions { TRACE_ADD, TRACE_LIST, TRACE_REMOVE };
        static char *opStrings[] = { "delete", "rename", (char *) NULL };
        enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME };
    
        switch ((enum traceOptions) optionIndex) {
            case TRACE_ADD: 
            case TRACE_REMOVE: {
                int flags = 0;
                int i, listLen, result;
                Tcl_Obj **elemPtrs;
                if (objc != 6) {
                    Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
                    return TCL_ERROR;
                }
                /*
                 * Make sure the ops argument is a list object; get its length and
                 * a pointer to its array of element pointers.
                 */

                result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
                        &elemPtrs);
                if (result != TCL_OK) {
                    return result;
                }
                if (listLen == 0) {
                    Tcl_SetResult(interp, "bad operation list \"\": must be "
                            "one or more of delete or rename", TCL_STATIC);
                    return TCL_ERROR;
                }
                for (i = 0; i < listLen; i++) {
                    if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
                            "operation", TCL_EXACT, &index) != TCL_OK) {
                        return TCL_ERROR;
                    }
                    switch ((enum operations) index) {
                        case TRACE_CMD_RENAME:
                            flags |= TCL_TRACE_RENAME;
                            break;
                        case TRACE_CMD_DELETE:
                            flags |= TCL_TRACE_DELETE;
                            break;
                    }
                }
                command = Tcl_GetStringFromObj(objv[5], &commandLength);
                length = (size_t) commandLength;
                if ((enum traceOptions) optionIndex == TRACE_ADD) {
                    TraceCommandInfo *tcmdPtr;
                    tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
                            (sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
                                    + length + 1));
                    tcmdPtr->flags = flags;
                    tcmdPtr->errMsg = NULL;
                    tcmdPtr->length = length;
                    flags |= TCL_TRACE_DELETE;
                    strcpy(tcmdPtr->command, command);
                    name = Tcl_GetString(objv[3]);
                    if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
                            (ClientData) tcmdPtr) != TCL_OK) {
                        ckfree((char *) tcmdPtr);
                        return TCL_ERROR;
                    }
                } else {
                    /*
                     * Search through all of our traces on this command to
                     * see if there's one with the given command.  If so, then
                     * delete the first one that matches.
                     */
                    
                    TraceCommandInfo *tcmdPtr;
                    ClientData clientData;
                    clientData = 0;
                    name = Tcl_GetString(objv[3]);
                    while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
                            TraceCommandProc, clientData)) != 0) {
                        tcmdPtr = (TraceCommandInfo *) clientData;
                        if ((tcmdPtr->length == length)
                                && (tcmdPtr->flags == flags)
                                && (strncmp(command, tcmdPtr->command,
                                        (size_t) length) == 0)) {
                            Tcl_UntraceCommand(interp, name,
                                    flags | TCL_TRACE_DELETE,
                                    TraceCommandProc, clientData);
                            if (tcmdPtr->errMsg != NULL) {
                                ckfree(tcmdPtr->errMsg);
                            }
                            ckfree((char *) tcmdPtr);
                            break;
                        }
                    }
                }
                break;
            }
            case TRACE_LIST: {
                ClientData clientData;
                Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
                if (objc != 4) {
                    Tcl_WrongNumArgs(interp, 3, objv, "name");
                    return TCL_ERROR;
                }

                resultListPtr = Tcl_GetObjResult(interp);
                clientData = 0;
                name = Tcl_GetString(objv[3]);
                while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
                        TraceCommandProc, clientData)) != 0) {

                    TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;

                    eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);

                    /*
                     * Build a list with the ops list as
                     * the first obj element and the tcmdPtr->command string
                     * as the second obj element.  Append this list (as an
                     * element) to the end of the result object list.
                     */

                    elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
                    if (tcmdPtr->flags & TCL_TRACE_RENAME) {
                        Tcl_ListObjAppendElement(NULL, elemObjPtr,
                                Tcl_NewStringObj("rename",6));
                    }
                    if (tcmdPtr->flags & TCL_TRACE_DELETE) {
                        Tcl_ListObjAppendElement(NULL, elemObjPtr,
                                Tcl_NewStringObj("delete",6));
                    }
                    Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);

                    elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1);
                    Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
                    Tcl_ListObjAppendElement(interp, resultListPtr,
                            eachTraceObjPtr);
                }
                Tcl_SetObjResult(interp, resultListPtr);
                break;
            }
        }
        return TCL_OK;
    }
#endif


/*
 *----------------------------------------------------------------------
 *
 * TclTraceVariableObjCmd --
 *
 *      Helper function for Tcl_TraceObjCmd; implements the
 *      [trace {add|remove|list} variable ...] subcommands.
 *      See the user documentation for details on what these do.
 *
 * Results:
 *      Standard Tcl result.
 *
 * Side effects:
 *      Depends on the operation (add, remove, or list) being performed;
 *      may add or remove variable traces on a variable.
 *
 *----------------------------------------------------------------------
 */

#if 0
    int
    TclTraceVariableObjCmd(interp, optionIndex, objc, objv)
        Tcl_Interp *interp;                     /* Current interpreter. */
        int optionIndex;                        /* Add, list or remove */
        int objc;                               /* Number of arguments. */
        Tcl_Obj *CONST objv[];          /* Argument objects. */
    {
        int commandLength, index;
        char *name, *command;
        size_t length;
        enum traceOptions { TRACE_ADD, TRACE_LIST, TRACE_REMOVE };
        static char *opStrings[] = { "array", "read", "unset", "write",
                                         (char *) NULL };
        enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET,
                              TRACE_VAR_WRITE };
        
        switch ((enum traceOptions) optionIndex) {
            case TRACE_ADD: 
            case TRACE_REMOVE: {
                int flags = 0;
                int i, listLen, result;
                Tcl_Obj **elemPtrs;
                if (objc != 6) {
                    Tcl_WrongNumArgs(interp, 3, objv, "name opList command");
                    return TCL_ERROR;
                }
                /*
                 * Make sure the ops argument is a list object; get its length and
                 * a pointer to its array of element pointers.
                 */

                result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
                        &elemPtrs);
                if (result != TCL_OK) {
                    return result;
                }
                if (listLen == 0) {
                    Tcl_SetResult(interp, "bad operation list \"\": must be "
                            "one or more of array, read, unset, or write",
                            TCL_STATIC);
                    return TCL_ERROR;
                }
                for (i = 0; i < listLen ; i++) {
                    if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
                            "operation", TCL_EXACT, &index) != TCL_OK) {
                        return TCL_ERROR;
                    }
                    switch ((enum operations) index) {
                        case TRACE_VAR_ARRAY:
                            flags |= TCL_TRACE_ARRAY;
                            break;
                        case TRACE_VAR_READ:
                            flags |= TCL_TRACE_READS;
                            break;
                        case TRACE_VAR_UNSET:
                            flags |= TCL_TRACE_UNSETS;
                            break;
                        case TRACE_VAR_WRITE:
                            flags |= TCL_TRACE_WRITES;
                            break;
                    }
                }
                command = Tcl_GetStringFromObj(objv[5], &commandLength);
                length = (size_t) commandLength;
                if ((enum traceOptions) optionIndex == TRACE_ADD) {
                    TraceVarInfo *tvarPtr;
                    tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
                            (sizeof(TraceVarInfo) - sizeof(tvarPtr->command)
                                    + length + 1));
                    tvarPtr->flags = flags;
                    tvarPtr->errMsg = NULL;
                    tvarPtr->length = length;
                    flags |= TCL_TRACE_UNSETS;
                    strcpy(tvarPtr->command, command);
                    name = Tcl_GetString(objv[3]);
                    if (Tcl_TraceVar(interp, name, flags, TraceVarProc,
                            (ClientData) tvarPtr) != TCL_OK) {
                        ckfree((char *) tvarPtr);
                        return TCL_ERROR;
                    }
                } else {
                    /*
                     * Search through all of our traces on this variable to
                     * see if there's one with the given command.  If so, then
                     * delete the first one that matches.
                     */
                    
                    TraceVarInfo *tvarPtr;
                    ClientData clientData = 0;
                    name = Tcl_GetString(objv[3]);
                    while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
                            TraceVarProc, clientData)) != 0) {
                        tvarPtr = (TraceVarInfo *) clientData;
                        if ((tvarPtr->length == length)
                                && (tvarPtr->flags == flags)
                                && (strncmp(command, tvarPtr->command,
                                        (size_t) length) == 0)) {
                            Tcl_UntraceVar(interp, name, flags | TCL_TRACE_UNSETS,
                                    TraceVarProc, clientData);
                            if (tvarPtr->errMsg != NULL) {
                                ckfree(tvarPtr->errMsg);
                            }
                            ckfree((char *) tvarPtr);
                            break;
                        }
                    }
                }
                break;
            }
            case TRACE_LIST: {
                ClientData clientData;
                Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
                if (objc != 4) {
                    Tcl_WrongNumArgs(interp, 3, objv, "name");
                    return TCL_ERROR;
                }

                resultListPtr = Tcl_GetObjResult(interp);
                clientData = 0;
                name = Tcl_GetString(objv[3]);
                while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
                        TraceVarProc, clientData)) != 0) {

                    TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;

                    eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
                    /*
                     * Build a list with the ops list as
                     * the first obj element and the tcmdPtr->command string
                     * as the second obj element.  Append this list (as an
                     * element) to the end of the result object list.
                     */

                    elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
                    if (tvarPtr->flags & TCL_TRACE_ARRAY) {
                        Tcl_ListObjAppendElement(NULL, elemObjPtr,
                                Tcl_NewStringObj("array", 5));
                    }
                    if (tvarPtr->flags & TCL_TRACE_READS) {
                        Tcl_ListObjAppendElement(NULL, elemObjPtr,
                                Tcl_NewStringObj("read", 4));
                    }
                    if (tvarPtr->flags & TCL_TRACE_WRITES) {
                        Tcl_ListObjAppendElement(NULL, elemObjPtr,
                                Tcl_NewStringObj("write", 5));
                    }
                    if (tvarPtr->flags & TCL_TRACE_UNSETS) {
                        Tcl_ListObjAppendElement(NULL, elemObjPtr,
                                Tcl_NewStringObj("unset", 5));
                    }
                    Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);

                    elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
                    Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
                    Tcl_ListObjAppendElement(interp, resultListPtr,
                            eachTraceObjPtr);
                }
                Tcl_SetObjResult(interp, resultListPtr);
                break;
            }
        }
        return TCL_OK;
    }
#endif


/*
 *----------------------------------------------------------------------
 *
 * Tcl_CommandTraceInfo --
 *
 *      Return the clientData value associated with a trace on a
 *      command.  This procedure can also be used to step through
 *      all of the traces on a particular command that have the
 *      same trace procedure.
 *
 * Results:
 *      The return value is the clientData value associated with
 *      a trace on the given command.  Information will only be
 *      returned for a trace with proc as trace procedure.  If
 *      the clientData argument is NULL then the first such trace is
 *      returned;  otherwise, the next relevant one after the one
 *      given by clientData will be returned.  If the command
 *      doesn't exist, or if there are no (more) traces for it,
 *      then NULL is returned.
 *
 * Side effects:
 *      None.
 *
 *----------------------------------------------------------------------
 */

ClientData
Tcl_CommandTraceInfo(interp, cmdName, flags, proc, prevClientData)
    Tcl_Interp *interp;         /* Interpreter containing command. */
    char *cmdName;              /* Name of command. */
    int flags;                  /* OR-ed combo or TCL_GLOBAL_ONLY,
                                 * TCL_NAMESPACE_ONLY (can be 0). */
    Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */
    ClientData prevClientData;  /* If non-NULL, gives last value returned
                                 * by this procedure, so this call will
                                 * return the next trace after that one.
                                 * If NULL, this call will return the
                                 * first trace. */
{
    Command *cmdPtr;
    register CommandTrace *tracePtr;

    cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, 
                NULL, TCL_LEAVE_ERR_MSG);
    if (cmdPtr == NULL) {
        return NULL;
    }

    /*
     * Find the relevant trace, if any, and return its clientData.
     */

    tracePtr = cmdPtr->tracePtr;
    if (prevClientData != NULL) {
        for ( ;  tracePtr != NULL;  tracePtr = tracePtr->nextPtr) {
            if ((tracePtr->clientData == prevClientData)
                    && (tracePtr->traceProc == proc)) {
                tracePtr = tracePtr->nextPtr;
                break;
            }
        }
    }
    for ( ;  tracePtr != NULL;  tracePtr = tracePtr->nextPtr) {
        if (tracePtr->traceProc == proc) {
            return tracePtr->clientData;
        }
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_TraceCommand --
 *
 *      Arrange for rename/deletes to a command to cause a
 *      procedure to be invoked, which can monitor the operations.
 *
 * Results:
 *      A standard Tcl return value.
 *
 * Side effects:
 *      A trace is set up on the command given by cmdName, such that
 *      future changes to the command will be intermediated by
 *      proc.  See the manual entry for complete details on the calling
 *      sequence for proc.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_TraceCommand(interp, cmdName, flags, proc, clientData)
    Tcl_Interp *interp;         /* Interpreter in which command is
                                 * to be traced. */
    char *cmdName;              /* Name of command. */
    int flags;                  /* OR-ed collection of bits, including any
                                 * of TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
    Tcl_CommandTraceProc *proc; /* Procedure to call when specified ops are
                                 * invoked upon varName. */
    ClientData clientData;      /* Arbitrary argument to pass to proc. */
{
    Command *cmdPtr;
    register CommandTrace *tracePtr;

    cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
            NULL, TCL_LEAVE_ERR_MSG);
    if (cmdPtr == NULL) {
        return TCL_ERROR;
    }

    /*
     * Set up trace information.
     */

    tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace));
    tracePtr->traceProc = proc;
    tracePtr->clientData = clientData;
    tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE);
    tracePtr->nextPtr = cmdPtr->tracePtr;
    cmdPtr->tracePtr = tracePtr;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UntraceCommand --
 *
 *      Remove a previously-created trace for a command.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      If there exists a trace for the command given by cmdName
 *      with the given flags, proc, and clientData, then that trace
 *      is removed.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData)
    Tcl_Interp *interp;         /* Interpreter containing command. */
    char *cmdName;              /* Name of command. */
    int flags;                  /* OR-ed collection of bits, including any
                                 * of TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
    Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */
    ClientData clientData;      /* Arbitrary argument to pass to proc. */
{
    register CommandTrace *tracePtr;
    CommandTrace *prevPtr;
    Command *cmdPtr;
    Interp *iPtr = (Interp *) interp;
    ActiveCommandTrace *activePtr;

    cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName, 
                NULL, TCL_LEAVE_ERR_MSG);
    if (cmdPtr == NULL) {
        return;
    }

    flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE);
    for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL;  ;
         prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
        if (tracePtr == NULL) {
            return;
        }
        if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
                && (tracePtr->clientData == clientData)) {
            break;
        }
    }

    /*
     * The code below makes it possible to delete traces while traces
     * are active: it makes sure that the deleted trace won't be
     * processed by CallTraces.
     */

    for (activePtr = iPtr->activeCmdTracePtr;  activePtr != NULL;
         activePtr = activePtr->nextPtr) {
        if (activePtr->nextTracePtr == tracePtr) {
            activePtr->nextTracePtr = tracePtr->nextPtr;
        }
    }
    if (prevPtr == NULL) {
        cmdPtr->tracePtr = tracePtr->nextPtr;
    } else {
        prevPtr->nextPtr = tracePtr->nextPtr;
    }
    ckfree((char *) tracePtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TraceCommandProc --
 *
 *      This procedure is called to handle command changes that have
 *      been traced using the "trace" command.
 *
 * Results:
 *      None.
 *
 * Side effects:
 *      Depends on the command associated with the trace.
 *
 *----------------------------------------------------------------------
 */

        /* ARGSUSED */
static void
TraceCommandProc(clientData, interp, oldName, newName, flags)
    ClientData clientData;      /* Information about the command trace. */
    Tcl_Interp *interp;         /* Interpreter containing command. */
    char *oldName;              /* Name of command being changed. */
    char *newName;              /* New name of command.  Empty string
                                 * or NULL means command is being deleted
                                 * (renamed to ""). */
    int flags;                  /* OR-ed bits giving operation and other
                                 * information. */
{
    Tcl_SavedResult state;
    TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
    int code;
    Tcl_DString cmd;

    if (tcmdPtr->errMsg != NULL) {
        ckfree(tcmdPtr->errMsg);
        tcmdPtr->errMsg = NULL;
    }
    if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
        /*
         * Generate a command to execute by appending list elements
         * for the old and new command name and the operation.
         */

        if (newName == NULL) {
            newName = "";
        }
        Tcl_DStringInit(&cmd);
        Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length);
        Tcl_DStringAppendElement(&cmd, oldName);
        Tcl_DStringAppendElement(&cmd, newName);
        if (flags & TCL_TRACE_RENAME) {
            Tcl_DStringAppend(&cmd, " rename", 7);
        } else if (flags & TCL_TRACE_DELETE) {
            Tcl_DStringAppend(&cmd, " delete", 7);
        }

        /*
         * Execute the command.  Save the interp's result used for
         * the command. We discard any object result the command returns.
         */

        Tcl_SaveResult(interp, &state);

        code = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
        if (code != TCL_OK) {        
            /* We ignore errors in these traced commands */
        }

        Tcl_RestoreResult(interp, &state);

        Tcl_DStringFree(&cmd);
    }
    if (flags & TCL_TRACE_DESTROYED) {
        if (tcmdPtr->errMsg != NULL) {
            ckfree(tcmdPtr->errMsg);
        }
        ckfree((char *) tcmdPtr);
    }
    return;
}

/*
 *----------------------------------------------------------------------
 *
 * TraceVarProc --
 *
 *      This procedure is called to handle variable accesses that have
 *      been traced using the "trace" command.
 *
 * Results:
 *      Normally returns NULL.  If the trace command returns an error,
 *      then this procedure returns an error string.
 *
 * Side effects:
 *      Depends on the command associated with the trace.
 *
 *----------------------------------------------------------------------
 */

        /* ARGSUSED */
static char *
TraceVarProc(clientData, interp, name1, name2, flags)
    ClientData clientData;      /* Information about the variable trace. */
    Tcl_Interp *interp;         /* Interpreter containing variable. */
    char *name1;                /* Name of variable or array. */
    char *name2;                /* Name of element within array;  NULL means
                                 * scalar variable is being referenced. */
    int flags;                  /* OR-ed bits giving operation and other
                                 * information. */
{
    Tcl_SavedResult state;
    TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
    char *result;
    int code;
    Tcl_DString cmd;

    result = NULL;
    if (tvarPtr->errMsg != NULL) {
        ckfree(tvarPtr->errMsg);
        tvarPtr->errMsg = NULL;
    }
    if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
        if (tvarPtr->length != (size_t) 0) {
            /*
             * Generate a command to execute by appending list elements
             * for the two variable names and the operation. 
             */

            if (name2 == NULL) {
                name2 = "";
            }
            Tcl_DStringInit(&cmd);
            Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length);
            Tcl_DStringAppendElement(&cmd, name1);
            Tcl_DStringAppendElement(&cmd, name2);
#ifndef TCL_REMOVE_OBSOLETE_TRACES
            if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) {
                if (flags & TCL_TRACE_ARRAY) {
                    Tcl_DStringAppend(&cmd, " a", 2);
                } else if (flags & TCL_TRACE_READS) {
                    Tcl_DStringAppend(&cmd, " r", 2);
                } else if (flags & TCL_TRACE_WRITES) {
                    Tcl_DStringAppend(&cmd, " w", 2);
                } else if (flags & TCL_TRACE_UNSETS) {
                    Tcl_DStringAppend(&cmd, " u", 2);
                }
            } else {
#endif
                if (flags & TCL_TRACE_ARRAY) {
                    Tcl_DStringAppend(&cmd, " array", 6);
                } else if (flags & TCL_TRACE_READS) {
                    Tcl_DStringAppend(&cmd, " read", 5);
                } else if (flags & TCL_TRACE_WRITES) {
                    Tcl_DStringAppend(&cmd, " write", 6);
                } else if (flags & TCL_TRACE_UNSETS) {
                    Tcl_DStringAppend(&cmd, " unset", 6);
                }
#ifndef TCL_REMOVE_OBSOLETE_TRACES
            }
#endif
            
            /*
             * Execute the command.  Save the interp's result used for
             * the command. We discard any object result the command returns.
             */

            Tcl_SaveResult(interp, &state);

            code = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
            if (code != TCL_OK) {            /* copy error msg to result */
                char *string;
                int length;
                
                string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
                tvarPtr->errMsg = (char *) ckalloc((unsigned) (length + 1));
                memcpy(tvarPtr->errMsg, string, (size_t) (length + 1));
                result = tvarPtr->errMsg;
            }

            Tcl_RestoreResult(interp, &state);

            Tcl_DStringFree(&cmd);
        }
    }
    if (flags & TCL_TRACE_DESTROYED) {
        result = NULL;
        if (tvarPtr->errMsg != NULL) {
            ckfree(tvarPtr->errMsg);
        }
        ckfree((char *) tvarPtr);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WhileObjCmd --
 *
 *      This procedure is invoked to process the "while" Tcl command.
 *      See the user documentation for details on what it does.
 *
 *      With the bytecode compiler, this procedure is only called when
 *      a command name is computed at runtime, and is "while" or the name
 *      to which "while" was renamed: e.g., "set z while; $z {$i<100} {}"
 *
 * Results:
 *      A standard Tcl result.
 *
 * Side effects:
 *      See the user documentation.
 *
 *----------------------------------------------------------------------
 */

        /* ARGSUSED */
int
Tcl_WhileObjCmd(dummy, interp, objc, objv)
    ClientData dummy;                   /* Not used. */
    Tcl_Interp *interp;                 /* Current interpreter. */
    int objc;                           /* Number of arguments. */
    Tcl_Obj *CONST objv[];              /* Argument objects. */
{
    int result, value;

    if (objc != 3) {
        Tcl_WrongNumArgs(interp, 1, objv, "test command");
        return TCL_ERROR;
    }

    while (1) {
        result = Tcl_ExprBooleanObj(interp, objv[1], &value);
        if (result != TCL_OK) {
            return result;
        }
        if (!value) {
            break;
        }
        result = Tcl_EvalObjEx(interp, objv[2], 0);
        if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
            if (result == TCL_ERROR) {
                char msg[32 + TCL_INTEGER_SPACE];

                sprintf(msg, "\n    (\"while\" body line %d)",
                        interp->errorLine);
                Tcl_AddErrorInfo(interp, msg);
            }
            break;
        }
    }
    if (result == TCL_BREAK) {
        result = TCL_OK;
    }
    if (result == TCL_OK) {
        Tcl_ResetResult(interp);
    }
    return result;
}

